home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / type.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-06-05  |  31.2 KB  |  779 lines
  1. ;;;; TYPEP und Verwandtes
  2. ;;;; Michael Stoll, 21. 10. 1988
  3. ;;;; Bruno Haible, 10.6.1989
  4.  
  5. ;;; Datenstrukturen für TYPEP:
  6. ;;; - Ein Type-Specifier-Symbol hat auf seiner Propertyliste unter dem
  7. ;;;   Indikator SYS::TYPE-SYMBOL eine Funktion von einem Argument, die
  8. ;;;   testet, ob ein Objekt vom richtigen Typ ist.
  9. ;;; - Ein Symbol, das eine Type-Specifier-Liste beginnen kann, hat auf seiner
  10. ;;;   Propertyliste unter dem Indikator SYS::TYPE-LIST eine Funktion von
  11. ;;;   einem Argument für das zu testende Objekt und zusätzlichen Argumenten
  12. ;;;   für die Listenelemente.
  13. ;;; - Ein Symbol, das als Typmacro definiert wurde, hat auf seiner Property-
  14. ;;;   liste unter dem Indikator SYSTEM::DEFTYPE-EXPANDER den zugehörigen
  15. ;;;   Expander: eine Funktion, die den zu expandierenden Type-Specifier (eine
  16. ;;;   mindestens einelementige Liste) als Argument bekommt.
  17.  
  18. (in-package "SYSTEM")
  19.  
  20. (defun type-error (fun type)
  21.   (error #+DEUTSCH "~S: ~S ist keine zugelassene Typspezifikation."
  22.          #+ENGLISH "~S: invalid type specification ~S"
  23.          #+FRANCAIS "~S : ~S n'est pas une spécification de type légale."
  24.          fun type
  25. ) )
  26.  
  27. ;;; TYPEP, CLTL S. 72, S. 42-51
  28. (defun typep (x y &aux f) ; x = Objekt, y = Typ
  29.   (cond
  30.     ((symbolp y)
  31.        (cond ((setq f (get y 'TYPE-SYMBOL)) (funcall f x))
  32.              ((setq f (get y 'TYPE-LIST)) (funcall f x))
  33.              ((setq f (get y 'DEFTYPE-EXPANDER)) (typep x (funcall f (list y))))
  34.              ((get y 'DEFSTRUCT-DESCRIPTION) (%STRUCTURE-TYPE-P y x))
  35.              (t (type-error 'typep y))
  36.     )  )
  37.     ((and (consp y) (symbolp (first y)))
  38.        (cond
  39.          ((and (eq (first y) 'SATISFIES) (eql (length y) 2))
  40.             (unless (symbolp (second y))
  41.               (error #+DEUTSCH "~S: Argument zu SATISFIES muß Symbol sein: ~S"
  42.                      #+ENGLISH "~S: argument to SATISFIES must be a symbol: ~S"
  43.                      #+FRANCAIS "~S : L'argument de SATISFIES doit être un symbole: ~S"
  44.                      'typep (second y)
  45.             ) )
  46.             (if (funcall (symbol-function (second y)) x) t nil)
  47.          )
  48.          ((eq (first y) 'MEMBER)
  49.             (if (member x (rest y)) t nil)
  50.          )
  51.          ((and (eq (first y) 'NOT) (eql (length y) 2))
  52.             (not (typep x (second y)))
  53.          )
  54.          ((eq (first y) 'AND)
  55.             (dolist (type (rest y) t)
  56.               (unless (typep x type) (return nil))
  57.          )  )
  58.          ((eq (first y) 'OR)
  59.             (dolist (type (rest y) nil)
  60.               (when (typep x type) (return t))
  61.          )  )
  62.          ((setq f (get (first y) 'TYPE-LIST)) (apply f x (rest y)))
  63.          ((setq f (get (first y) 'DEFTYPE-EXPANDER)) (typep x (funcall f y)))
  64.          (t (type-error 'typep y))
  65.     )  )
  66.     (t (type-error 'typep y))
  67. ) )
  68.  
  69. ; CLTL S. 43
  70. (%put 'ARRAY 'TYPE-SYMBOL #'arrayp)
  71. (%put 'ATOM 'TYPE-SYMBOL #'atom)
  72. (%put 'BIGNUM 'TYPE-SYMBOL
  73.   (function type-symbol-bignum
  74.     (lambda (x) (and (integerp x) (not (fixnump x))))
  75. ) )
  76. (%put 'BIT 'TYPE-SYMBOL
  77.   (function type-symbol-bit
  78.     (lambda (x) (or (eql x 0) (eql x 1)))
  79. ) )
  80. (%put 'BIT-VECTOR 'TYPE-SYMBOL #'bit-vector-p)
  81. (%put 'CHARACTER 'TYPE-SYMBOL #'characterp)
  82. (%put 'COMMON 'TYPE-SYMBOL #'commonp)
  83. (%put 'COMPILED-FUNCTION 'TYPE-SYMBOL #'compiled-function-p)
  84. (%put 'COMPLEX 'TYPE-SYMBOL #'complexp)
  85. (%put 'CONS 'TYPE-SYMBOL #'consp)
  86. (%put 'DOUBLE-FLOAT 'TYPE-SYMBOL #'double-float-p)
  87. (%put 'FIXNUM 'TYPE-SYMBOL #'fixnump)
  88. (%put 'FLOAT 'TYPE-SYMBOL #'floatp)
  89. (%put 'FUNCTION 'TYPE-SYMBOL #'functionp)
  90. (%put 'HASH-TABLE 'TYPE-SYMBOL #'hash-table-p)
  91. (%put 'INTEGER 'TYPE-SYMBOL #'integerp)
  92. (%put 'KEYWORD 'TYPE-SYMBOL #'keywordp)
  93. (%put 'LIST 'TYPE-SYMBOL #'listp)
  94. (%put 'LONG-FLOAT 'TYPE-SYMBOL #'long-float-p)
  95. (%put 'NIL 'TYPE-SYMBOL
  96.   (function type-symbol-nil
  97.     (lambda (x) (declare (ignore x)) nil)
  98. ) )
  99. (%put 'NULL 'TYPE-SYMBOL #'null)
  100. (%put 'NUMBER 'TYPE-SYMBOL #'numberp)
  101. (%put 'PACKAGE 'TYPE-SYMBOL #'packagep)
  102. (%put 'PATHNAME 'TYPE-SYMBOL #'pathnamep)
  103. (%put 'RANDOM-STATE 'TYPE-SYMBOL #'random-state-p)
  104. (%put 'RATIO 'TYPE-SYMBOL
  105.   (function type-symbol-ratio
  106.     (lambda (x) (and (rationalp x) (not (integerp x))))
  107. ) )
  108. (%put 'RATIONAL 'TYPE-SYMBOL #'rationalp)
  109. (%put 'READTABLE 'TYPE-SYMBOL #'readtablep)
  110. (%put 'REAL 'TYPE-SYMBOL #'realp)
  111. (%put 'SEQUENCE 'TYPE-SYMBOL #'sequencep)
  112. (%put 'SHORT-FLOAT 'TYPE-SYMBOL #'short-float-p)
  113. (%put 'SIMPLE-ARRAY 'TYPE-SYMBOL #'simple-array-p)
  114. (%put 'SIMPLE-BIT-VECTOR 'TYPE-SYMBOL #'simple-bit-vector-p)
  115. (%put 'SIMPLE-STRING 'TYPE-SYMBOL #'simple-string-p)
  116. (%put 'SIMPLE-VECTOR 'TYPE-SYMBOL #'simple-vector-p)
  117. (%put 'SINGLE-FLOAT 'TYPE-SYMBOL #'single-float-p)
  118. (%put 'STANDARD-CHAR 'TYPE-SYMBOL
  119.   (function type-symbol-standard-char
  120.     (lambda (x) (and (characterp x) (standard-char-p x)))
  121. ) )
  122. (%put 'STREAM 'TYPE-SYMBOL #'streamp)
  123. (%put 'STRING 'TYPE-SYMBOL #'stringp)
  124. (%put 'STRING-CHAR 'TYPE-SYMBOL
  125.   (function type-symbol-string-char
  126.     (lambda (x) (and (characterp x) (string-char-p x)))
  127. ) )
  128. (%put 'STRUCTURE 'TYPE-SYMBOL
  129.   (function type-symbol-structure
  130.     (lambda (x)
  131.       (let ((y (type-of x)))
  132.         (and (symbolp y) (get y 'DEFSTRUCT-DESCRIPTION)
  133.              (%STRUCTURE-TYPE-P y x)
  134. ) ) ) ) )
  135. (%put 'SYMBOL 'TYPE-SYMBOL #'symbolp)
  136. (%put 'T 'TYPE-SYMBOL
  137.   (function type-symbol-t
  138.     (lambda (x) (declare (ignore x)) t)
  139. ) )
  140. (%put 'VECTOR 'TYPE-SYMBOL #'vectorp)
  141.  
  142. ; CLTL S. 46-50
  143. (defun upgraded-array-element-type (type)
  144.   #+CLISP1 ; siehe ARRAY.Q
  145.   (case type
  146.     ((STRING-CHAR BIT) type)
  147.     (t 'T)
  148.   )
  149.   #-CLISP1 ; siehe ARRAY.D
  150.   (case type
  151.     ((BIT STRING-CHAR T) type)
  152.     (t (multiple-value-bind (low high) (sys::subtype-integer type)
  153.          ; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high))
  154.          (if (and (integerp low) (not (minusp low)) (integerp high))
  155.            (let ((l (integer-length high)))
  156.              ; Es gilt (subtypep type `(UNSIGNED-BYTE ,l))
  157.              (cond ((<= l 1) 'BIT)
  158.                    ((<= l 2) '(UNSIGNED-BYTE 2))
  159.                    ((<= l 4) '(UNSIGNED-BYTE 4))
  160.                    ((<= l 8) '(UNSIGNED-BYTE 8))
  161.                    ((<= l 16) '(UNSIGNED-BYTE 16))
  162.                    ((<= l 32) '(UNSIGNED-BYTE 32))
  163.                    (t 'T)
  164.            ) )
  165.            'T
  166.   ) )  ) )
  167. )
  168. (%put 'ARRAY 'TYPE-LIST
  169.   (function type-list-array
  170.     (lambda (x &optional (el-type '*) (dims '*))
  171.       (and (arrayp x)
  172.            (or (eq el-type '*)
  173.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  174.            )
  175.            (or (eq dims '*)
  176.                (if (numberp dims)
  177.                  (eql dims (array-rank x))
  178.                  (and (eql (length dims) (array-rank x))
  179.                       (every #'(lambda (a b) (or (eq a '*) (eql a b)))
  180.                              dims (array-dimensions x)
  181.   ) ) )    )   ) )    )
  182. )
  183. (%put 'SIMPLE-ARRAY 'TYPE-LIST
  184.   (function type-list-simple-array
  185.     (lambda (x &optional (el-type '*) (dims '*))
  186.       (and (simple-array-p x)
  187.            (or (eq el-type '*)
  188.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  189.            )
  190.            (or (eq dims '*)
  191.                (if (numberp dims)
  192.                  (eql dims (array-rank x))
  193.                  (and (eql (length dims) (array-rank x))
  194.                       (every #'(lambda (a b) (or (eq a '*) (eql a b)))
  195.                              dims (array-dimensions x)
  196.   ) ) )    )   ) )    )
  197. )
  198. (%put 'VECTOR 'TYPE-LIST
  199.   (function type-list-vector
  200.     (lambda (x &optional (el-type '*) (size '*))
  201.       (and (vectorp x)
  202.            (or (eq el-type '*)
  203.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  204.            )
  205.            (or (eq size '*) (eql (array-dimension x 0) size))
  206.   ) ) )
  207. )
  208. (%put 'SIMPLE-VECTOR 'TYPE-LIST
  209.   (function type-list-simple-vector
  210.     (lambda (x &optional (size '*))
  211.       (and (simple-vector-p x)
  212.            (or (eq size '*) (eql size (array-dimension x 0)))
  213.   ) ) )
  214. )
  215. (%put 'COMPLEX 'TYPE-LIST
  216.   (function type-list-complex
  217.     (lambda (x &optional (rtype '*) (itype rtype))
  218.       (and (complexp x)
  219.            (or (eq rtype '*) (typep (realpart x) rtype))
  220.            (or (eq itype '*) (typep (imagpart x) itype))
  221.   ) ) )
  222. )
  223. (%put 'INTEGER 'TYPE-LIST
  224.   (function type-list-integer
  225.     (lambda (x &optional (low '*) (high '*))
  226.       (typep-number-test x low high #'integerp 'INTEGER)
  227.   ) )
  228. )
  229. (defun typep-number-test (x low high test type)
  230.   (and (funcall test x)
  231.        (cond ((eq low '*))
  232.              ((funcall test low) (<= low x))
  233.              ((and (consp low) (null (rest low)) (funcall test (first low)))
  234.                 (< (first low) x)
  235.              )
  236.              (t (error #+DEUTSCH "~S: Argument zu ~S muß *, ~S oder eine Liste von ~S sein: ~S"
  237.                        #+ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  238.                        #+FRANCAIS "~S : L'argument de ~S doit être *, ~S ou une liste de ~S: ~S"
  239.                        'typep type type type low
  240.        )     )  )
  241.        (cond ((eq high '*))
  242.              ((funcall test high) (>= high x))
  243.              ((and (consp high) (null (rest high)) (funcall test (first high)))
  244.                 (> (first high) x)
  245.              )
  246.              (t (error #+DEUTSCH "~S: Argument zu ~S muß *, ~S oder eine Liste von ~S sein: ~S"
  247.                        #+ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  248.                        #+FRANCAIS "~S : L'argument de ~S doit être *, ~S ou une liste de ~S: ~S"
  249.                        'typep type type type high
  250. ) )    )     )  )
  251. (%put 'MOD 'TYPE-LIST
  252.   (function type-list-mod
  253.     (lambda (x n)
  254.       (unless (integerp n)
  255.         (error #+DEUTSCH "~S: Argument zu MOD muß ganze Zahl sein: ~S"
  256.                #+ENGLISH "~S: argument to MOD must be an integer: ~S"
  257.                #+FRANCAIS "~S : L'argument de MOD doit être un entier: ~S"
  258.                'typep n
  259.       ) )
  260.       (and (integerp x) (<= 0 x) (< x n))
  261.   ) )
  262. )
  263. (%put 'SIGNED-BYTE 'TYPE-LIST
  264.   (function type-list-signed-byte
  265.     (lambda (x &optional (n '*))
  266.       (unless (or (eq n '*) (integerp n))
  267.         (error #+DEUTSCH "~S: Argument zu SIGNED-BYTE muß ganze Zahl oder * sein: ~S"
  268.                #+ENGLISH "~S: argument to SIGNED-BYTE must be an integer or * : ~S"
  269.                #+FRANCAIS "~S : L'argument de SIGNED-BYTE doit être un entier ou bien * : ~S"
  270.                'typep n
  271.       ) )
  272.       (and (integerp x) (or (eq n '*) (< (integer-length x) n)))
  273.   ) )
  274. )
  275. (%put 'UNSIGNED-BYTE 'TYPE-LIST
  276.   (function type-list-unsigned-byte
  277.     (lambda (x &optional (n '*))
  278.       (unless (or (eq n '*) (integerp n))
  279.         (error #+DEUTSCH "~S: Argument zu UNSIGNED-BYTE muß ganze Zahl oder * sein: ~S"
  280.                #+ENGLISH "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S"
  281.                #+FRANCAIS "~S : L'argument de UNSIGNED-BYTE doit être un entier ou bien * : ~S"
  282.                'typep n
  283.       ) )
  284.       (and (integerp x)
  285.            (not (minusp x))
  286.            (or (eq n '*) (<= (integer-length x) n))
  287.   ) ) )
  288. )
  289. (%put 'REAL 'TYPE-LIST
  290.   (function type-list-real
  291.     (lambda (x &optional (low '*) (high '*))
  292.       (typep-number-test x low high #'realp 'REAL)
  293.   ) )
  294. )
  295. (%put 'RATIONAL 'TYPE-LIST
  296.   (function type-list-rational
  297.     (lambda (x &optional (low '*) (high '*))
  298.       (typep-number-test x low high #'rationalp 'RATIONAL)
  299.   ) )
  300. )
  301. (%put 'FLOAT 'TYPE-LIST
  302.   (function type-list-float
  303.     (lambda (x &optional (low '*) (high '*))
  304.       (typep-number-test x low high #'floatp 'FLOAT)
  305.   ) )
  306. )
  307. (%put 'SHORT-FLOAT 'TYPE-LIST
  308.   (function type-list-short-float
  309.     (lambda (x &optional (low '*) (high '*))
  310.       (typep-number-test x low high #'short-float-p 'SHORT-FLOAT)
  311.   ) )
  312. )
  313. (%put 'SINGLE-FLOAT 'TYPE-LIST
  314.   (function type-list-single-float
  315.     (lambda (x &optional (low '*) (high '*))
  316.       (typep-number-test x low high #'single-float-p 'SINGLE-FLOAT)
  317.   ) )
  318. )
  319. (%put 'DOUBLE-FLOAT 'TYPE-LIST
  320.   (function type-list-double-float
  321.     (lambda (x &optional (low '*) (high '*))
  322.       (typep-number-test x low high #'double-float-p 'DOUBLE-FLOAT)
  323.   ) )
  324. )
  325. (%put 'LONG-FLOAT 'TYPE-LIST
  326.   (function type-list-long-float
  327.     (lambda (x &optional (low '*) (high '*))
  328.       (typep-number-test x low high #'long-float-p 'LONG-FLOAT)
  329.   ) )
  330. )
  331. (%put 'STRING 'TYPE-LIST
  332.   (function type-list-string
  333.     (lambda (x &optional (size '*))
  334.       (and (stringp x)
  335.            (or (eq size '*) (eql size (array-dimension x 0)))
  336.   ) ) )
  337. )
  338. (%put 'SIMPLE-STRING 'TYPE-LIST
  339.   (function type-list-simple-string
  340.     (lambda (x &optional (size '*))
  341.       (and (simple-string-p x)
  342.            (or (eq size '*) (eql size (array-dimension x 0)))
  343.   ) ) )
  344. )
  345. (%put 'BIT-VECTOR 'TYPE-LIST
  346.   (function type-list-bit-vector
  347.     (lambda (x &optional (size '*))
  348.       (and (bit-vector-p x)
  349.            (or (eq size '*) (eql size (array-dimension x 0)))
  350.   ) ) )
  351. )
  352. (%put 'SIMPLE-BIT-VECTOR 'TYPE-LIST
  353.   (function type-list-simple-bit-vector
  354.     (lambda (x &optional (size '*))
  355.       (and (simple-bit-vector-p x)
  356.            (or (eq size '*) (eql size (array-dimension x 0)))
  357.   ) ) )
  358. )
  359.  
  360. ; Testet eine Liste von Werten auf Erfüllen eines Type-Specifiers. Für THE.
  361. (defun %the (values type)
  362.   (if (and (consp type) (eq (car type) 'VALUES))
  363.     (macrolet ((type-error ()
  364.                  '(error #+DEUTSCH "Falsch aufgebauter Type-Specifier: ~S"
  365.                          #+ENGLISH "Invalid type specifier ~S"
  366.                          #+FRANCAIS "Spécificateur de type mal formé : ~S"
  367.                          type
  368.               ))  )
  369.       (let ((vals values)
  370.             (types (cdr type)))
  371.         ; required-Werte:
  372.         (loop
  373.           (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  374.             (return)
  375.           )
  376.           (unless (and (consp vals) (typep (car vals) (car types)))
  377.             (return-from %the nil)
  378.           )
  379.           (setq vals (cdr vals))
  380.           (setq types (cdr types))
  381.         )
  382.         ; optionale Werte:
  383.         (when (and (consp types) (eq (car types) '&optional))
  384.           (setq types (cdr types))
  385.           (loop
  386.             (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  387.               (return)
  388.             )
  389.             (when (consp vals)
  390.               (unless (typep (car vals) (car types)) (return-from %the nil))
  391.               (setq vals (cdr vals))
  392.             )
  393.             (setq types (cdr types))
  394.         ) )
  395.         ; restliche Werte:
  396.         (if (atom types)
  397.           (when (consp vals) (return-from %the nil))
  398.           (case (car types)
  399.             (&rest
  400.               (setq types (cdr types))
  401.               (when (atom types) (type-error))
  402.               (unless (typep vals (car types)) (return-from %the nil))
  403.               (setq types (cdr types))
  404.             )
  405.             (&key)
  406.             (t (type-error))
  407.         ) )
  408.         ; Keyword-Werte:
  409.         (when (consp types)
  410.           (if (eq (car types) '&key)
  411.             (progn
  412.               (setq types (cdr types))
  413.               (when (oddp (length vals)) (return-from %the nil))
  414.               (let ((keywords nil))
  415.                 (loop
  416.                   (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  417.                     (return)
  418.                   )
  419.                   (let ((item (car types)))
  420.                     (unless (and (listp item) (eql (length item) 2) (symbolp (first item)))
  421.                       (type-error)
  422.                     )
  423.                     (let ((kw (intern (symbol-name (first item)) *keyword-package*)))
  424.                       (unless (typep (getf vals kw) (second item))
  425.                         (return-from %the nil)
  426.                       )
  427.                       (push kw keywords)
  428.                   ) )
  429.                   (setq types (cdr types))
  430.                 )
  431.                 (if (and (consp types) (eq (car types) '&allow-other-keys))
  432.                   (setq types (cdr types))
  433.                   (unless (getf vals ':allow-other-keys)
  434.                     (do ((L vals (cddr L)))
  435.                         ((atom L))
  436.                       (unless (member (car L) keywords :test #'eq)
  437.                         (return-from %the nil)
  438.                 ) ) ) )
  439.             ) )
  440.             (when (consp types) (type-error))
  441.         ) )
  442.         t
  443.     ) )
  444.     (typep (if (consp values) (car values) nil) type) ; 1. Wert abtesten
  445. ) )
  446.  
  447. ;;; SUBTYPEP, vorläufige Version
  448. (defun canonicalize-type (type) ; type ein wenig vereinfachen, nicht rekursiv
  449.   (cond ((symbolp type)
  450.          (let ((f (get type 'DEFTYPE-EXPANDER)))
  451.            (if f
  452.              (canonicalize-type (funcall f (list type))) ; macroexpandieren
  453.              (case type
  454.                (ATOM '(NOT CONS))
  455.                (BIGNUM '(AND INTEGER (NOT FIXNUM)))
  456.                (BIT '(INTEGER 0 1))
  457.                (COMMON '(OR CONS SYMBOL NUMBER ARRAY STANDARD-CHAR
  458.                          STREAM PACKAGE HASH-TABLE READTABLE PATHNAME RANDOM-STATE
  459.                          STRUCTURE
  460.                )        )
  461.                (FIXNUM '(INTEGER #,most-negative-fixnum #,most-positive-fixnum))
  462.                (KEYWORD '(AND SYMBOL (SATISFIES KEYWORDP)))
  463.                (LIST '(OR CONS (MEMBER NIL)))
  464.                ((NIL) '(OR))
  465.                (NULL '(MEMBER NIL))
  466.                (RATIO '(AND RATIONAL (NOT INTEGER)))
  467.                (SEQUENCE '(OR LIST VECTOR)) ; user-defined sequences??
  468.                (STANDARD-CHAR '(AND CHARACTER (SATISFIES STRING-CHAR-P) (SATISFIES STANDARD-CHAR-P)))
  469.                (STRING-CHAR '(AND CHARACTER (SATISFIES STRING-CHAR-P)))
  470.                ((T) '(AND))
  471.                ((ARRAY SIMPLE-ARRAY BIT-VECTOR SIMPLE-BIT-VECTOR
  472.                  STRING SIMPLE-STRING VECTOR SIMPLE-VECTOR
  473.                  COMPLEX REAL INTEGER RATIONAL FLOAT
  474.                  SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT
  475.                 )
  476.                  (canonicalize-type (list type))
  477.                )
  478.                (t type)
  479.         )) ) )
  480.         ((and (consp type) (symbolp (first type)))
  481.          (let ((f (get (first type) 'DEFTYPE-EXPANDER)))
  482.            (if f
  483.              (canonicalize-type (funcall f type)) ; macroexpandieren
  484.              (case (first type)
  485.                (MEMBER ; (MEMBER &rest objects)
  486.                  (if (null (rest type)) '(OR) type)
  487.                )
  488.                (MOD ; (MOD n)
  489.                  (let ((n (second type)))
  490.                    (unless (and (integerp n) (>= n 0)) (type-error 'subtypep type))
  491.                    `(INTEGER 0 (,n))
  492.                ) )
  493.                (SIGNED-BYTE ; (SIGNED-BYTE &optional s)
  494.                  (let ((s (or (second type) '*)))
  495.                    (if (eq s '*)
  496.                      'INTEGER
  497.                      (progn
  498.                        (unless (and (integerp s) (plusp s)) (type-error 'subtypep type))
  499.                        (let ((n (expt 2 (1- s))))
  500.                          `(INTEGER ,(- n) (,n))
  501.                ) ) ) ) )
  502.                (UNSIGNED-BYTE ; (UNSIGNED-BYTE &optional s)
  503.                  (let ((s (or (second type) '*)))
  504.                    (if (eq s '*)
  505.                      '(INTEGER 0 *)
  506.                      (progn
  507.                        (unless (and (integerp s) (>= s 0)) (type-error 'subtypep type))
  508.                        (let ((n (expt 2 s)))
  509.                          `(INTEGER 0 (,n))
  510.                ) ) ) ) )
  511.                (SIMPLE-BIT-VECTOR ; (SIMPLE-BIT-VECTOR &optional size)
  512.                  (let ((size (or (second type) '*)))
  513.                    `(SIMPLE-ARRAY BIT (,size))
  514.                ) )
  515.                (SIMPLE-STRING ; (SIMPLE-STRING &optional size)
  516.                  (let ((size (or (second type) '*)))
  517.                    `(SIMPLE-ARRAY STRING-CHAR (,size))
  518.                ) )
  519.                (SIMPLE-VECTOR ; (SIMPLE-VECTOR &optional size)
  520.                  (let ((size (or (second type) '*)))
  521.                    `(SIMPLE-ARRAY T (,size))
  522.                ) )
  523.                (BIT-VECTOR ; (BIT-VECTOR &optional size)
  524.                  (let ((size (or (second type) '*)))
  525.                    `(ARRAY BIT (,size))
  526.                ) )
  527.                (STRING ; (STRING &optional size)
  528.                  (let ((size (or (second type) '*)))
  529.                    `(ARRAY STRING-CHAR (,size))
  530.                ) )
  531.                (VECTOR ; (VECTOR &optional el-type size)
  532.                  (let ((el-type (or (second type) '*))
  533.                        (size (or (third type) '*)))
  534.                    `(ARRAY ,el-type (,size))
  535.                ) )
  536.                (t type)
  537.         )) ) )
  538. ) )
  539. (defun subtypep (type1 type2)
  540.   (macrolet ((yes () '(return-from subtypep (values t t)))
  541.              (no () '(return-from subtypep (values nil t)))
  542.              (unknown () '(return-from subtypep (values nil nil))))
  543.     (setq type1 (canonicalize-type type1))
  544.     (setq type2 (canonicalize-type type2))
  545.     (when (equal type1 type2) (yes)) ; (subtypep type type) stimmt immer
  546.     (when (consp type1)
  547.       (cond ;; über SATISFIES-Typen kann man nichts aussagen
  548.             ;((and (eq (first type1) 'SATISFIES) (eql (length type1) 2))
  549.             ; (unknown)
  550.             ;)
  551.             ;; MEMBER: alle Elemente müssen vom Typ type2 sein
  552.             ((eq (first type1) 'MEMBER)
  553.              (dolist (x (rest type1) (yes))
  554.                (unless (typep x type2) (return (no)))
  555.             ))
  556.             ;; NOT: (subtypep `(NOT ,type1) `(NOT ,type2)) ist äquivalent
  557.             ;; zu (subtypep type2 type1), sonst ist Entscheidung schwierig
  558.             ((and (eq (first type1) 'NOT) (eql (length type1) 2))
  559.              (return-from subtypep
  560.                (if (and (consp type2) (eq (first type2) 'NOT) (eql (length type2) 2))
  561.                  (subtypep (second type2) (second type1))
  562.                  (unknown)
  563.             )) )
  564.             ;; OR: Jeder Typ muß Subtyp von type2 sein
  565.             ((eq (first type1) 'OR)
  566.              (dolist (type (rest type1) (yes))
  567.                (multiple-value-bind (is known) (subtypep type type2)
  568.                  (unless is (return-from subtypep (values nil known)))
  569.             )) )
  570.     ) )
  571.     (when (consp type2)
  572.       (cond ;; über SATISFIES-Typen kann man nichts aussagen
  573.             ;((and (eq (first type2) 'SATISFIES) (eql (length type2) 2))
  574.             ; (unknown)
  575.             ;)
  576.             ;; NOT: siehe oben
  577.             ((and (eq (first type2) 'NOT) (eql (length type2) 2))
  578.              (unknown)
  579.             )
  580.             ;; AND: type1 muß Subtyp jedes der Typen sein
  581.             ((eq (first type2) 'AND)
  582.              (dolist (type (rest type2) (yes))
  583.                (multiple-value-bind (is known) (subtypep type1 type)
  584.                  (unless is (return-from subtypep (values nil known)))
  585.             )) )
  586.             ;; OR: Falls type1 Subtyp eines der Typen ist, sonst nicht bekannt
  587.             ((eq (first type2) 'OR)
  588.              (dolist (type (rest type2) (unknown))
  589.                (when (subtypep type1 type) (return (yes)))
  590.             ))
  591.     ) )
  592.     (when (consp type1)
  593.       (cond ;; AND: Falls ein Typ Subtyp von type2 ist, sonst nicht bekannt
  594.             ((eq (first type1) 'AND)
  595.              (dolist (type (rest type1) (unknown))
  596.                (when (subtypep type type2) (return (yes)))
  597.             ))
  598.     ) )
  599.     (when (and (symbolp type1) (get type1 'DEFSTRUCT-DESCRIPTION)
  600.                (symbolp type2)
  601.           )
  602.       (when (eq type2 'STRUCTURE) (yes))
  603.       (when (get type2 'DEFSTRUCT-DESCRIPTION)
  604.         (let ((inclist1 (svref (get type1 'DEFSTRUCT-DESCRIPTION) 0))
  605.               (inclist2 (svref (get type2 'DEFSTRUCT-DESCRIPTION) 0)))
  606.           (loop
  607.             (when (eq inclist1 inclist2) (return (yes)))
  608.             (when (atom inclist1) (return))
  609.             (setq inclist1 (cdr inclist1))
  610.       ) ) )
  611.     )
  612.     (when (atom type1) (setq type1 (list type1)))
  613.     (case (first type1)
  614.       ((ARRAY SIMPLE-ARRAY)
  615.         (macrolet ((array-p (type)
  616.                      `(or (eq ,type 'ARRAY) (eq ,type (first type1)))
  617.                   ))
  618.           (let ((el-type1 (if (rest type1) (second type1) '*))
  619.                 (dims1 (if (cddr type1) (third type1) '*)))
  620.             (values
  621.               (cond ((array-p type2) t)
  622.                     ((and (consp type2) (array-p (first type2)))
  623.                      (let ((el-type2 (if (rest type2) (second type2) '*))
  624.                            (dims2 (if (cddr type2) (third type2) '*)))
  625.                        (and (or (eq el-type2 '*)
  626.                                 (and (not (eq el-type1 '*))
  627.                                      (equal (upgraded-array-element-type el-type1)
  628.                                             (upgraded-array-element-type el-type2)
  629.                             )   )    )
  630.                             (or (eq dims2 '*)
  631.                                 (and (listp dims1) (listp dims2)
  632.                                      (eql (length dims1) (length dims2))
  633.                                      (every #'(lambda (a b) (or (eq b '*) (= a b)))
  634.                                               dims1 dims2
  635.                     )) )    )   )    )
  636.                     (t nil)
  637.               )
  638.               t
  639.       ) ) ) )
  640.       (COMPLEX
  641.         (let* ((rtype1 (if (rest type1) (second type1) '*))
  642.                (itype1 (if (cddr type1) (third type1) rtype1)))
  643.           (values
  644.             (cond ((or (eq type2 'COMPLEX) (eq type2 'NUMBER)) t)
  645.                   ((and (consp type2) (eq (first type2) 'COMPLEX))
  646.                    (let* ((rtype2 (if (rest type2) (second type2) '*))
  647.                           (itype2 (if (cddr type2) (third type2) rtype2)))
  648.                      (and (or (eq rtype2 '*)
  649.                               (and (not (eq rtype1 '*))
  650.                                    (subtypep rtype1 rtype2)
  651.                           )   )
  652.                           (or (eq itype2 '*)
  653.                               (and (not (eq itype1 '*))
  654.                                    (subtypep itype1 itype2)
  655.                   )) )    )   )
  656.                   (t nil)
  657.             )
  658.             t
  659.       ) ) )
  660.       ((REAL INTEGER RATIONAL FLOAT SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
  661.         (let ((typelist
  662.                 (cons (first type1)
  663.                   (case (first type1)
  664.                     (REAL '(NUMBER))
  665.                     (INTEGER '(RATIONAL REAL NUMBER))
  666.                     ((RATIONAL FLOAT) '(REAL NUMBER))
  667.                     ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT) '(FLOAT REAL NUMBER))
  668.               ) ) )
  669.               (low1 (if (rest type1) (second type1) '*))
  670.               (high1 (if (cddr type1) (third type1) '*))
  671.               (integer-flag1 (eq (first type1) 'INTEGER))
  672.               (efl t)
  673.               (efh t))
  674.           (when (consp low1)
  675.             (setq low1 (first low1))
  676.             (if integer-flag1 (when (numberp low1) (incf low1)) (setq efl nil))
  677.           )
  678.           (when (consp high1)
  679.             (setq high1 (first high1))
  680.             (if integer-flag1 (when (numberp high1) (decf high1)) (setq efh nil))
  681.           )
  682.           ; efl gibt an, ob low1 zu type1 dazugehört.
  683.           ; efh gibt an, ob high1 zu type1 dazugehört.
  684.           (cond ((and (numberp low1) (numberp high1)
  685.                       (not (or (< low1 high1) (and (= low1 high1) efl efh)))
  686.                  ) ; type1 leer?
  687.                  (yes)
  688.                 )
  689.                 ((member type2 typelist) (yes))
  690.                 ((and (consp type2) (member (first type2) typelist))
  691.                  (let ((low2 (if (rest type2) (second type2) '*))
  692.                        (high2 (if (cddr type2) (third type2) '*))
  693.                        (integer-flag2 (eq (first type2) 'INTEGER)))
  694.                    (if (consp low2)
  695.                      (progn (setq low2 (first low2))
  696.                             (when integer-flag2 (when (numberp low2) (incf low2)) (setq efl nil))
  697.                      )
  698.                      (setq efl nil)
  699.                    )
  700.                    (if (consp high2)
  701.                      (progn (setq high2 (first high2))
  702.                             (when integer-flag2 (when (numberp high2) (decf high2)) (setq efh nil))
  703.                      )
  704.                      (setq efh nil)
  705.                    )
  706.                    ; efl gibt an, ob low1 zu type1 dazugehört und low2 zu type2 nicht dazugehört.
  707.                    ; efh gibt an, ob high1 zu type1 dazugehört und high2 zu type2 nicht dazugehört.
  708.                    (values
  709.                      (and (or (eq low2 '*)
  710.                               (and (numberp low1)
  711.                                    (if efl (> low1 low2) (>= low1 low2))
  712.                           )   )
  713.                           (or (eq high2 '*)
  714.                               (and (numberp high1)
  715.                                    (if efh (< high1 high2) (<= high1 high2))
  716.                      )    )   )
  717.                      t
  718.                 )) )
  719.                 (t (values nil (not integer-flag1)))
  720.       ) ) )
  721.       (t (unknown))
  722. ) ) )
  723.  
  724. ;; Bestimmt zwei Werte low,high so, daß (subtypep type `(INTEGER ,low ,high))
  725. ;; gilt und low möglichst groß und high möglichst klein ist.
  726. ;; low = * bedeutet -unendlich, high = * bedeutet unendlich.
  727. ;; Werte sind NIL,NIL falls (subtypep type 'INTEGER) falsch ist.
  728. ;; Wir brauchen diese Funktion nur für MAKE-ARRAY und UPGRADED-ARRAY-ELEMENT-TYPE,
  729. ;; dürfen also oBdA  type  durch  `(OR ,type (MEMBER 0))  ersetzen.
  730. (defun subtype-integer (type)
  731.   (macrolet ((yes () '(return-from subtype-integer (values low high)))
  732.              (no () '(return-from subtype-integer nil))
  733.              (unknown () '(return-from subtype-integer nil)))
  734.     (setq type (canonicalize-type type))
  735.     (if (consp type)
  736.       (macrolet ((min* (x y) `(if (or (eq ,x '*) (eq ,y '*)) '* (min ,x ,y)))
  737.                  (max* (x y) `(if (or (eq ,x '*) (eq ,y '*)) '* (max ,x ,y))))
  738.         (case (first type)
  739.           (MEMBER ;; MEMBER: alle Elemente müssen vom Typ INTEGER sein
  740.             (let ((low 0) (high 0)) ; oBdA!
  741.               (dolist (x (rest type) (yes))
  742.                 (unless (typep x 'INTEGER) (return (no)))
  743.                 (setq low (min low x) high (max high x))
  744.           ) ) )
  745.           (OR ;; OR: Jeder Typ muß Subtyp von INTEGER sein
  746.             (let ((low 0) (high 0)) ; oBdA!
  747.               (dolist (type1 (rest type) (yes))
  748.                 (multiple-value-bind (low1 high1) (subtype-integer type1)
  749.                   (unless low1 (return (no)))
  750.                   (setq low (min* low low1) high (max* high high1))
  751.           ) ) ) )
  752.           (AND ;; AND: Falls ein Typ Subtyp von INTEGER ist, sonst nicht bekannt
  753.             ;; Hier könnte man die verschiedenen Integer-Subtypen schneiden.
  754.             (dolist (type1 (rest type) (unknown))
  755.               (multiple-value-bind (low high) (subtype-integer type1)
  756.                 (when low (return (yes)))
  757.           ) ) )
  758.       ) )
  759.       (setq type (list type))
  760.     )
  761.     (if (eq (first type) 'INTEGER)
  762.       (let ((low (if (rest type) (second type) '*))
  763.             (high (if (cddr type) (third type) '*)))
  764.         (when (consp low)
  765.           (setq low (first low))
  766.           (when (numberp low) (incf low))
  767.         )
  768.         (when (consp high)
  769.           (setq high (first high))
  770.           (when (numberp high) (decf high))
  771.         )
  772.         (when (and (numberp low) (numberp high) (not (<= low high))) ; type leer?
  773.           (setq low 0 high 0)
  774.         )
  775.         (yes)
  776.       )
  777.       (unknown)
  778. ) ) )
  779.